home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Cream of the Crop 26
/
Cream of the Crop 26.iso
/
program
/
p063b9s.zip
/
UNIT
/
OPROUTIL.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1996-04-28
|
18KB
|
660 lines
UNIT OproUtil;
{╔══════════════════════════════════════════════════════════════════════════╗}
{║ Misc. routines for OPro Last changed: 28.04.96 SA ║}
{║ ║}
{║ (C) Copyright 1989-96 by ║}
{║ Dan Wulff, Jens Sandalgaard, Steen Christensen & S¢ren Ager ║}
{║ ║}
{║ This source may not be given to anybody, without the written permission ║}
{║ from The Portal Team. ║}
{╚══════════════════════════════════════════════════════════════════════════╝}
{$I POPDEFS.INC}
INTERFACE
USES Use32, Dos, OpCrt, OpWindow, OpMenu, OpField, OpEntry, OpRoot,
PoPTypes;
CONST
ptBitYesNoConversion = 2000;
otBitYesNoEField = 1101;
veBitYesNoEField = 0;
TYPE
PBufTextFile = ^TBufTextFile;
TBufTextFile = OBJECT(BufIdStream)
ReadWrite : Boolean;
CONSTRUCTOR Init(CONST FileName: PathStr; Mode, Size : Word);
CONSTRUCTOR InitCreate(FileName: PathStr; Mode, Size: Word);
PROCEDURE ReadLn(VAR s: String);
PROCEDURE WriteLn(s: String);
PROCEDURE WriteNoLn(s: String);
PROCEDURE ReadLenStr(VAR s: String; Len: Byte);
FUNCTION EoF: Boolean;
END;
PPoPEntryScreen = ^TPoPEntryScreen;
TPoPEntryScreen = OBJECT(ScrollingEntryScreen)
CONSTRUCTOR Init(x1, y1, x2, y2, Col: Byte; CONST s: s78);
DESTRUCTOR Done; VIRTUAL;
PROCEDURE Process; VIRTUAL;
PROCEDURE AddBitYesNoField(Prompt: STRING; pRow, pCol : Word;
Picture: STRING; fRow, fCol : Word;
HelpIndex: Word; BitNr: Byte; VAR EditBitYesNo: SmallWord);
END;
PBitYesNoField = ^TBitYesNoField;
TBitYesNoField = OBJECT(EntryField)
BitNr : Byte;
constructor Init(ID : Word; var Prompt : string;
pRow, pCol : Word; var Picture : string;
fRow, fCol : Word; HlpNdx : Word;
ABitNr: Byte; var EditBitYesNo : SmallWord; PadChar : Char;
Options, IFlags : LongInt; var Colors : ColorSet);
procedure efIncrement; VIRTUAL;
constructor Load(var S : IdStream);
procedure Store(var S : IdStream); VIRTUAL;
END;
PPoPMenu = ^TPoPMenu;
TPoPMenu = OBJECT(Menu)
CONSTRUCTOR Init(x1, y1, x2, y2, Col: Byte; CONST s: s78);
DESTRUCTOR Done; VIRTUAL;
PROCEDURE ProcessMenu(VAR Choice, LastCmd: Word);
END;
{ Stream registration }
PROCEDURE TPoPEntryScreenStream(SPtr: IdStreamPtr);
PROCEDURE TPoPMenuStream(SPtr: IdStreamPtr);
PROCEDURE TBitYesNoFieldStream(SPtr: IdStreamPtr);
PROCEDURE CenterWindow(VAR x1, x2: Byte);
FUNCTION MyWin(VAR w : WindowPtr; x1, y1, x2, y2, l : Byte; CONST s: String; Shadow: Boolean): Boolean;
PROCEDURE KillWindow(VAR w : WindowPtr);
PROCEDURE LoadMainMenu;
PROCEDURE MainMenuToggle;
FUNCTION GetDiskString(Drive: Char): S25;
IMPLEMENTATION
USES {$IFDEF OS2} Os2Base, VpRoot, {$ELSE} OpMacro, {$ENDIF} OpDos,
OpInline, OpFrame, OpSelect, OpCmd, OpKey, OpAbsFld, OpFEdit, OpConst,
Globals, Resource, PoPHelp;
{=== TBufTextFile ===}
CONSTRUCTOR TBufTextFile.Init(CONST FileName: PathStr; Mode, Size: Word);
BEGIN
Size:=(Size DIV 512)*512;
IF Size=0 THEN Size:=512;
IF NOT INHERITED Init(FileName, Mode, Size) THEN Fail;
IF GetStatus<>0 THEN
BEGIN
INHERITED Done;
Fail;
END;
ReadWrite:=((Mode AND SOpen)=SOpen) OR ((Mode AND SCreate)=SCreate);
END;
CONSTRUCTOR TBufTextFile.InitCreate(FileName: PathStr; Mode, Size: Word);
BEGIN
IF NOT ExistFile(FileName) THEN Mode:=SCreate;
IF NOT Init(FileName, Mode, Size) THEN Fail;
SetPos(0, PosEnd);
END;
Procedure TBufTextFile.ReadLn(var S: String);
var
SPos : Byte;
Ch : Char;
{$IFNDEF OS2}
Regs : Registers;
{$ENDIF}
begin
S[0]:=#0; SPos:=0; Ch:=#0;
{ if idStatus<>0 then Exit;}
if ReadWrite and not FlushBuffer(1) then Exit; { = FlushModeWrite }
repeat
if BufPtr>=BufEnd then
{$IFDEF OS2}
asm
push ebx
mov eax,self
mov ebx,[eax].DosIdStream.Handle
mov ecx,[eax].DosIdStream.BufSize
mov edx,[eax].DosIdStream.Buffer
mov ah,3fh { Read }
Call Os2DosFn
jnc @@1 { success }
add eax,epNonFatal { error }
push eax
mov eax,Self
push eax
Call Error
jmp @@2
@@1:
mov ebx,self
xor ecx,ecx
mov [ebx].DosIdStream.bufptr,ecx
mov [ebx].DosIdStream.bufend,eax
or eax,eax { check if bytes read = 0 }
jne @@2
mov eax,epNonFatal { nope - disk full }
add eax,ecDiskRead
push eax
mov eax,Self
push eax
Call Error
@@2:
pop ebx
end;
{$ELSE}
begin
with Regs do
begin
AH := $3F;
BX := Handle;
CX := BufSize;
DX := OS(Buffer).O;
DS := OS(Buffer).S;
MsDos(Regs);
BufPtr:=0;
IF Odd(Flags) THEN BufEnd:=0 ELSE BufEnd:=AX;
end;
end;
{$ENDIF}
WHILE (BufPtr<BufEnd) AND (Ch<>#10) DO
BEGIN
Ch:=Char(Buffer^[BufPtr]);
IF (not (ch in [#13, #10])) AND (SPos<=255) THEN
BEGIN
Inc(SPos);
s[SPos]:=ch;
END;
Inc(BufPtr);
END;
UNTIL (Ch=#10) or (BufEnd=0);
S[0]:=Char(SPos);
END;
PROCEDURE TBufTextFile.WriteLn(s: String);
BEGIN
Write(s[1], Length(s));
s:=#13#10;
Write(s[1], Length(s));
END;
PROCEDURE TBufTextFile.WriteNoLn(s: String);
BEGIN
Write(s[1], Length(s));
END;
PROCEDURE TBufTextFile.ReadLenStr(VAR s: String; Len: Byte);
BEGIN
Read(s[1], Len);
s[0]:=Char(Len);
END;
{$IFDEF OS2}
FUNCTION TBufTextFile.EoF: Boolean;
VAR
OldPos, NewPos : LongInt;
BEGIN
DosSetFilePtr(Handle, 0, FILE_CURRENT, OldPos);
DosSetFilePtr(Handle, 0, FILE_END, NewPos);
DosSetFilePtr(Handle, OldPos, FILE_BEGIN, OldPos);
EoF:=(OldPos=NewPos) AND (BufPtr>=BufEnd);
END;
{$ELSE}
FUNCTION TBufTextFile.EoF: Boolean;
VAR
Regs : Registers;
OldDX, OldAX,
MaxDX, MaxAX : Word;
BEGIN
IF (BufPtr>0) AND (Succ(BufPtr)<BufEnd) THEN
EoF:=False
ELSE
begin
(*
ASM
mov ax,$4201
mov bx,Handle
mov cx,0
mov dx,0
int $21
mov OldDx,dx
mov OldAx,ax
mov ax,$4202
mov bx,Handle
mov cx,0
mov dx,0
int $21
mov MaxDx,dx
mov MaxAx,ax
mov ax,$4200
mov bx,Handle
mov cx,OldDx
mov dx,OldAX
int $21
END;
*)
WITH Regs DO
BEGIN
ax:=$4201;
bx:=Handle;
cx:=0;
dx:=0;
MsDos(Regs);
OldDX:=DX;
OldAX:=AX;
ax:=$4202;
bx:=Handle;
cx:=0;
dx:=0;
MsDos(Regs);
MaxDX:=DX;
MaxAX:=AX;
ax:=$4200;
bx:=Handle;
cx:=OldDX;
dx:=OldAX;
MsDos(Regs);
END;
EoF:=(OldDX=MaxDX) AND (OldAX=MaxAX) AND (BufPtr>=BufEnd);
END;
END;
{$ENDIF}
{=== TPoPEntryScreen ===}
CONSTRUCTOR TPoPEntryScreen.Init(x1, y1, x2, y2, Col: Byte; CONST s: s78);
BEGIN
CenterWindow(x1, x2);
IF NOT INHERITED InitCustom(x1,y1,x2,y2,Cfg.Color[col],wBordered+wClear) THEN Fail;
WFrame.AddHeader(' '+s+' ',heTC);
IF (x2<ScreenWidth-2) AND (y2<ScreenHeight-2) THEN WFrame.AddShadow(shBR, shSeeThru);
IF cfg.Screen.ExplodingWin THEN EnableExplosions(10);
esFieldOptionsOn(efClearFirstChar);
SetWrapMode(ExitAtBot);
EntryCommands.AddCommand(ccPrevRec,1,OpKey.PgUp,0);
EntryCommands.AddCommand(ccNextRec,1,OpKey.PgDn,0);
EntryCommands.SetHelpProc(HelpRoutine);
Topic:=0;
END;
DESTRUCTOR TPoPEntryScreen.Done;
BEGIN
EraseHidden;
INHERITED Done;
END;
PROCEDURE TPoPEntryScreen.Process;
BEGIN
ResetScreen;
INHERITED Process;
END;
PROCEDURE TPoPEntryScreen.AddBitYesNoField(Prompt: STRING; pRow, pCol : Word;
Picture: STRING; fRow, fCol : Word;
HelpIndex: Word; BitNr: Byte; VAR EditBitYesNo: SmallWord);
VAR
fWidth : Byte;
BEGIN
{check parameters before adding the field}
fWidth := Length(Picture);
if esParamsOK(Prompt, pRow, pCol, Picture, fRow, fCol, fWidth) then
{allocate field and append it to the linked list}
esAppendField(
New(PBitYesNoField,
Init(asCount, Prompt, pRow, pCol, Picture, fRow, fCol, HelpIndex,
BitNr, EditBitYesNo, esPadChar, asFieldOptions, esFieldFlags, asColors)));
END;
procedure BitYesNoConversion(EFP: EntryFieldPtr; PostEdit: Boolean); far;
{-Conversion routine for yes/no's}
var
Ch : Char;
S : string[10];
begin
with PBitYesNoField(EFP)^ do
if PostEdit then
begin
StripPicture(efEditSt^, S);
Ch := S[1];
IF Upcase(Ch) = YesChar THEN
Word(efVarPtr^):=Word(efVarPtr^) OR (1 SHL BitNr)
ELSE
Word(efVarPtr^):=Word(efVarPtr^) AND NOT (1 SHL BitNr);
end else
begin
if Word(efVarPtr^) AND (1 SHL BitNr) <> 0 then
efEditSt^ := YesChar
else
efEditSt^ := NoChar;
if Length(efEditSt^) < Length(efPicture^) then
MergePicture(efEditSt^, efEditSt^);
end;
end;
constructor TBitYesNoField.Init(ID : Word; var Prompt : string;
pRow, pCol : Word; var Picture : string;
fRow, fCol : Word; HlpNdx : Word;
ABitNr: Byte; var EditBitYesNo : SmallWord; PadChar : Char;
Options, IFlags : LongInt; var Colors : ColorSet);
{-Initialize an entry field of type yes-no}
var
fWidth : Byte;
begin
if Length(Picture) = 0 then
begin
Picture := YesNoOnly;
fWidth := 1;
end else
fWidth := Length(Picture);
if not INHERITED Init(
ID, Prompt, pRow, pCol, Picture, fRow, fCol, fWidth, 1, HlpNdx,
BlankRange, BlankRange, SizeOf(Boolean), 0, NullValidation, BitYesNoConversion,
DrawString, CharEditor, EditBitYesNo, PadChar, Options or efClickExit,
IFlags or ifBoolean, Colors) then
Fail;
BitNr:=ABitNr;
end;
procedure TBitYesNoField.efIncrement;
{-Increment the value of the field}
begin
Word(efVarPtr^) := Word(efVarPtr^) XOR (1 SHL BitNr);
end;
constructor TBitYesNoField.Load(var S : IdStream);
BEGIN
INHERITED Load(S);
S.Read(BitNr, SizeOf(BitNr));
END;
procedure TBitYesNoField.Store(var S : IdStream);
BEGIN
INHERITED Store(S);
S.Write(BitNr, SizeOf(BitNr));
END;
{***}
procedure TBitYesNoFieldStream(SPtr : IdStreamPtr);
{-Register all types}
begin
EntryFieldStream(SPtr);
with SPtr^ do begin
RegisterType(otBitYesNoEField, veBitYesNoEField, TypeOf(TBitYesNoField),
@TBitYesNoField.Store, @TBitYesNoField.Load);
RegisterPointer(ptBitYesNoConversion, @BitYesNoConversion);
RegisterPointer(ptDrawString, @DrawString);
RegisterPointer(ptCharEditor, @CharEditor);
end;
end;
{=== TPoPMenu ===}
CONSTRUCTOR TPoPMenu.Init(x1, y1, x2, y2, Col: Byte; CONST s: s78);
BEGIN
CenterWindow(x1, x2);
IF NOT INHERITED InitCustom(x1,y1,x2,y2,Cfg.Color[col],wBordered+wCoversOnDemand,Vertical) THEN Fail;
WFrame.AddHeader(' '+s+' ',heTC);
IF (x2<ScreenWidth-2) AND (y2<ScreenHeight-2) THEN AddShadow(shBR, shSeeThru);
IF cfg.Screen.ExplodingWin THEN EnableExplosions(10);
Topic:=0 ;
END;
DESTRUCTOR TPoPMenu.Done;
BEGIN
EraseHidden;
INHERITED Done;
END;
PROCEDURE TPoPMenu.ProcessMenu(VAR Choice, LastCmd: Word);
BEGIN
Draw;
Process;
Choice:=MenuChoice;
LastCmd:=GetLastCommand;
Done;
END;
{=== Stream Registration ===}
PROCEDURE TPoPEntryScreenStream(SPtr: IdStreamPtr);
BEGIN
ScrollingEntryScreenStream(SPtr);
SPtr^.RegisterType(otTPopEntryScreen, veTPoPEntryScreen,
TypeOf(TPoPEntryScreen),
@TPoPEntryScreen.Store, @TPoPEntryScreen.Load);
END;
PROCEDURE TPoPMenuStream(SPtr: IdStreamPtr);
BEGIN
MenuStream(SPtr);
SPtr^.RegisterType(otTPopMenu, veTPoPMenu,
TypeOf(TPoPMenu),
@TPoPMenu.Store, @TPoPMenu.Load);
END;
PROCEDURE CenterWindow(VAR x1, x2: Byte);
BEGIN
IF ScreenWidth>80 THEN
BEGIN
Inc(x1, (ScreenWidth-80) DIV 2);
Inc(x2, (ScreenWidth-80) DIV 2);
END;
END;
FUNCTION MyWin(VAR w : WindowPtr; x1, y1, x2, y2, l : Byte; CONST s: String; Shadow: Boolean): Boolean;
VAR
Head : String;
cs : ColorSet;
b : LONGINT;
BEGIN
IF l=0 THEN cs:=DefaultColorSet ELSE cs:=Cfg.Color[l];
b:=wClear+wSaveContents;
CenterWindow(x1, x2);
IF s='' THEN
BEGIN
Head:='';
END ELSE
BEGIN
INC(x1);INC(y1);DEC(x2);DEC(y2);
Head:=' '+s+' ';
b:=b+wBordered;
END;
New(w, InitCustom(x1,y1,x2,y2,cs,b));
IF w<>NIL THEN
BEGIN
w^.SetCursor(cuHidden);
IF head<>'' THEN w^.WFrame.AddHeader(Head,heTC);
IF Cfg.Screen.ExplodingWin THEN w^.EnableExplosions(10);
IF Shadow THEN w^.wFrame.AddShadow(shBR,shSeeThru);
w^.Draw;
MyWin:=True;
END ELSE
MyWin:=False;
END;
PROCEDURE KillWindow(VAR w : WindowPtr);
BEGIN
w^.EraseHidden;
Dispose(w, Done);
END;
PROCEDURE InitM(VAR M:Menu; x1,y1,x2,y2,col:BYTE; CONST s: STRING);
BEGIN
WITH m DO
BEGIN
CenterWindow(x1, x2);
InitCustom(x1,y1,x2,y2,Cfg.Color[col],wBordered,Vertical);
WFrame.AddHeader(' '+s+' ',heTC);
IF cfg.Screen.ExplodingWin THEN EnableExplosions(6);
END;
Topic:=0 ;
END;
PROCEDURE _KillMenu(VAR m:Menu);
BEGIN
m.EraseHidden;
m.Done;
END;
PROCEDURE MainCustomStringProc(var Name : String; Key : LongInt;
Selected, Highlighted : Boolean;
WPtr : RawWindowPtr); far;
VAR
s : S5;
BEGIN
{$IFNDEF OS2}
IF Key=93 THEN
BEGIN
IF MacrosAreOn THEN s:='Yes' ELSE s:=' No';
Move(s[1], Name[Length(Name)-2], Length(s));
END;
{$ENDIF}
END;
PROCEDURE LoadMainMenu;
BEGIN
IF MainMenu=NIL THEN
BEGIN
New(MainMenu);
GetMenu(MnuMain, 2, MainMenu^);
MainMenu^.SetCustomStringProc(MainCustomStringProc);
MainMenu^.DefaultItem(100);
END;
MainMenuToggle;
END;
PROCEDURE MainMenuToggle;
BEGIN
WITH MainMenu^ DO
BEGIN
IF CmdLineFlags AND clNoModem<>0 THEN
BEGIN
ProtectItem(AltP);
ProtectItem(AltD);
ProtectItem(AltC);
ProtectItem(210);
ProtectItem(211);
ProtectItem(212);
END ELSE
BEGIN
UnProtectItem(AltP);
UnProtectItem(AltD);
UnProtectItem(AltC);
UnProtectItem(210);
UnProtectItem(211);
UnProtectItem(212);
IF Cfg.Modem.Answer='' THEN ProtectItem(211) ELSE UnProtectItem(211);
END;
IF OutList^.Size=0 THEN
BEGIN
ProtectItem(Plus);
ProtectItem(Minus);
ProtectItem(AltW);
ProtectItem(AltI);
END ELSE
BEGIN
UnProtectItem(Plus);
UnProtectItem(Minus);
UnProtectItem(AltW);
UnProtectItem(AltI);
END;
IF Cfg.Screen.BlankTime=0 THEN ProtectItem(AltB) ELSE UnProtectItem(AltB);
IF Cfg.Editor='' THEN ProtectItem(AltE) ELSE UnProtectItem(AltE);
IF Cfg.BBS.BBSType=btNone THEN
BEGIN
ProtectItem(AltA);
ProtectItem(AltQ);
ProtectItem(AltU);
END ELSE
BEGIN
UnProtectItem(AltA);
UnProtectItem(AltQ);
UnProtectItem(AltU);
END;
{$IFNDEF OS2}
IF MacroCount=0 THEN
BEGIN
ProtectItem(91);
ProtectItem(92);
ProtectItem(94);
ProtectItem(97);
END ELSE
BEGIN
UnProtectItem(91);
UnProtectItem(92);
UnProtectItem(94);
UnProtectItem(97);
END;
{$ENDIF}
{ ProtectItem(214);
ProtectItem(215);}
END;
END;
FUNCTION GetDiskString(Drive: Char): S25;
VAR
dc : DiskClass;
sd : Char;
BEGIN
GetDiskString:='';
dc:=GetDiskClass(Drive, sd);
CASE dc OF
Floppy360 : GetDiskString:='360KB floppy';
Floppy720 : GetDiskString:='720KB floppy';
Floppy12 : GetDiskString:='1.2MB floppy';
Floppy144 : GetDiskString:='1.44MB floppy';
OtherFloppy : GetDiskString:='Unknown floppy';
Bernoulli : GetDiskString:='Bernoulli drive';
HardDisk : GetDiskString:='Hard disk';
RamDisk : GetDiskString:='Ram drive';
SubstDrive : GetDiskString:='Substitute of drive '+sd;
UnknownDisk : GetDiskString:='Unknown media';
InvalidDrive : GetDiskString:='Invalid drive';
NovellDrive : GetDiskString:='Novell<tm> drive';
CDRomDisk : GetDiskString:='CD ROM drive';
END;
END;
END.